home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / ai.prl / opnprlg1.hqx / Open Prolog / External Predicates… / Sources / prlxLibraries.p < prev    next >
Text File  |  1993-04-15  |  15KB  |  504 lines
  1. {$D+} { MacsBug symbols on }
  2. {$R-} { No range checking }
  3.  
  4. UNIT prlxLibraries;
  5.  
  6.   INTERFACE
  7.  
  8.     USES memtypes, quickdraw, osintf, toolintf, packintf, prlxdefinitions;
  9.  
  10.     PROCEDURE writestr(st: str255; plist: prlxPtr);
  11.  
  12.     PROCEDURE writelnstr(st: str255; plist: prlxPtr);
  13.  
  14.     PROCEDURE errorstr(st: str255; plist: prlxPtr);
  15.  
  16.     FUNCTION returnValue(termNumber: termIndex; n: longint;
  17.                          plist: prlxPtr): boolean;
  18.  
  19.     FUNCTION returnStructure(termNumber: termIndex; st: str255; arity: integer;
  20.                              plist: prlxPtr): boolean;
  21.  
  22.     FUNCTION returnList(termNumber: termIndex; plist: prlxPtr): boolean;
  23.  
  24.     FUNCTION returnAtom(termNumber: termIndex; st: str255;
  25.                         plist: prlxPtr): boolean;
  26.  
  27.     FUNCTION returnUnifiedTerms(a, b: termIndex; plist: prlxPtr): boolean;
  28.  
  29.     FUNCTION subterm(subtermordinate: integer; termNumber: termIndex;
  30.                      plist: prlxPtr): termIndex;
  31.  
  32.     FUNCTION newFreeTerm(plist: prlxPtr): termIndex;
  33.  
  34.     FUNCTION number(termNumber: termIndex; plist: prlxPtr): boolean;
  35.  
  36.     FUNCTION atom(termNumber: termIndex; plist: prlxPtr): boolean;
  37.  
  38.     FUNCTION structure(termNumber: termIndex; plist: prlxPtr): boolean;
  39.  
  40.     FUNCTION list(termNumber: termIndex; plist: prlxPtr): boolean;
  41.  
  42.     FUNCTION variable(termNumber: termIndex; plist: prlxPtr): boolean;
  43.  
  44.     FUNCTION value(termNumber: termIndex; plist: prlxPtr): longint;
  45.  
  46.     FUNCTION arity(termNumber: termIndex; plist: prlxPtr): integer;
  47.  
  48.     FUNCTION text(termNumber: termIndex; plist: prlxPtr): str255;
  49.  
  50.     FUNCTION drawAlert(ALRTid: integer; st: str255; plist: prlxPtr): longint;
  51.  
  52.     FUNCTION centreDialog(DLOGid: integer; plist: prlxPtr): longint;
  53.  
  54.     PROCEDURE centreSfGetTEXTFile(vertical: integer; str: str255;
  55.                                   VAR reply: sfReply);
  56.  
  57.     PROCEDURE centreSfPutFile(vertical: integer; str: str255; origName: str255;
  58.                               dlgHook: procPtr; VAR reply: sfReply);
  59.  
  60.     FUNCTION getFileName(VAR FileName: str255;
  61.                          VAR FileVolume: longint): boolean;
  62.  
  63.     FUNCTION predicateNameAndArity(VAR name: str255; VAR arity: integer;
  64.                                    plist: prlxPtr): boolean;
  65.  
  66.     PROCEDURE signalError(error: integer; argumentIndex: termIndex;
  67.                           hostErrorCode: longint; errorMessage: str255;
  68.                           plist: prlxPtr);
  69.  
  70.   IMPLEMENTATION
  71.  
  72.     PROCEDURE signalError(error: integer; argumentIndex: termIndex;
  73.                           hostErrorCode: longint; errorMessage: str255;
  74.                           plist: prlxPtr);
  75.  
  76.     {if you want to throw an error from an external predicate, use this}
  77.     {error kind is an index to an ISO error type - see prlxDefinitions.p}
  78.     {hostErrorCode is where you can put a mac error code}
  79.  
  80.       VAR
  81.         i: integer;
  82.         t, r, q: termIndex;
  83.         ignoreBoolean: boolean;
  84.         thePredicateName: str255;
  85.         thePredicateArity: integer;
  86.  
  87.       BEGIN
  88.  
  89.         ignoreBoolean := predicateNameAndArity(thePredicateName,
  90.                                                thePredicateArity, plist);
  91.         t := newFreeTerm(plist);
  92.         ignoreBoolean := returnList(t, plist); {return a list of error
  93.                                                 information}
  94.         q := subterm(1, t, plist);
  95.         ignoreBoolean := returnStructure(q, 'goal', 1, plist); {first, the goal
  96.           - functor & arguments}
  97.         q := subterm(1, q, plist);
  98.         ignoreBoolean := returnStructure(q, thePredicateName, thePredicateArity,
  99.                                          plist);
  100.         FOR i := 1 TO thePredicateArity DO
  101.           ignoreBoolean := returnUnifiedTerms(subterm(i, q, plist), i, plist);{the
  102.           goal's arguments}
  103.         q := t;
  104.  
  105.         IF argumentIndex <> 0 {if the argument index = 0, no argument index info
  106.                                returned}
  107.           THEN
  108.             BEGIN
  109.             q := subterm(2, q, plist);
  110.             ignoreBoolean := returnList(q, plist);
  111.             r := subterm(1, q, plist);
  112.             ignoreBoolean := returnStructure(r, 'argument_index', 1, plist);
  113.             r := subterm(1, r, plist);
  114.             ignoreBoolean := returnValue(r, argumentIndex, plist);
  115.             END;
  116.  
  117.         IF hostErrorCode <> 0 {if the mac error code = 0, no host error info
  118.                                returned}
  119.           THEN
  120.             BEGIN
  121.             q := subterm(2, q, plist);
  122.             ignoreBoolean := returnList(q, plist);
  123.             r := subterm(1, q, plist);
  124.             ignoreBoolean := returnStructure(r, 'host_error_code', 1, plist);
  125.             r := subterm(1, r, plist);
  126.             ignoreBoolean := returnValue(r, hostErrorCode, plist);
  127.             END;
  128.  
  129.         IF errorMessage <> '' {only return an error message term if it's
  130.                                non-blank}
  131.           THEN
  132.             BEGIN
  133.             q := subterm(2, q, plist);
  134.             ignoreBoolean := returnList(q, plist);
  135.             r := subterm(1, q, plist);
  136.             ignoreBoolean := returnStructure(r, 'error_message', 1, plist);
  137.             r := subterm(1, r, plist);
  138.             ignoreBoolean := returnAtom(r, errorMessage, plist);
  139.             END;
  140.  
  141.         ignoreBoolean := returnAtom(subterm(2, q, plist), '[]', plist);
  142.  
  143.         WITH plist^ DO
  144.           BEGIN
  145.           outcome := error; {outcome is normally 'notAnErrorCode' - this puts a
  146.                              real error code there}
  147.           data[1] := t;
  148.           END;
  149.       END;
  150.  
  151.     PROCEDURE writestr(st: str255; plist: prlxPtr);
  152.  
  153.       BEGIN
  154.         WITH plist^ DO
  155.           BEGIN
  156.           callbackrequest := writestring;
  157.           s := st;
  158.           callback(entrypoint);
  159.           END;
  160.       END;
  161.  
  162.     PROCEDURE writelnstr(st: str255; plist: prlxPtr);
  163.  
  164.       BEGIN
  165.         WITH plist^ DO
  166.           BEGIN
  167.           callbackrequest := writelnstring;
  168.           s := st;
  169.           callback(entrypoint);
  170.           END;
  171.       END;
  172.  
  173.     PROCEDURE errorstr(st: str255; plist: prlxPtr);
  174.  
  175.       BEGIN
  176.         WITH plist^ DO
  177.           BEGIN
  178.           callbackrequest := writeerror;
  179.           s := st;
  180.           callback(entrypoint);
  181.           END;
  182.       END;
  183.  
  184.     FUNCTION predicateNameAndArity(VAR name: str255; VAR arity: integer;
  185.                                    plist: prlxPtr): boolean;
  186.  
  187.       BEGIN
  188.         WITH plist^ DO
  189.           BEGIN
  190.           callbackrequest := getPredicateNameAndArity;
  191.           callback(entrypoint);
  192.           predicateNameAndArity := callbackData[3] = messageOK;
  193.           name := s;
  194.           arity := callbackData[1];
  195.           END;
  196.       END;
  197.  
  198.     FUNCTION returnUnifiedTerms(a, b: termIndex; plist: prlxPtr): boolean;
  199.  
  200.       BEGIN
  201.         WITH plist^ DO
  202.           BEGIN
  203.           callbackrequest := unifyTerms;
  204.           callbackData[1] := a;
  205.           callbackData[2] := b;
  206.           callback(entrypoint);
  207.           returnUnifiedTerms := callbackData[3] = messageOK;
  208.           END;
  209.       END;
  210.  
  211.     FUNCTION returnValue(termNumber: termIndex; n: longint;
  212.                          plist: prlxPtr): boolean;
  213.  
  214.       BEGIN
  215.         WITH plist^ DO
  216.           BEGIN
  217.           callbackrequest := unifyToInteger;
  218.           callbackData[1] := termNumber;
  219.           callbackData[2] := n;
  220.           callback(entrypoint);
  221.           returnValue := callbackData[3] = messageOK;
  222.           END;
  223.       END;
  224.  
  225.     FUNCTION returnList(termNumber: termIndex; plist: prlxPtr): boolean;
  226.  
  227.       BEGIN
  228.         WITH plist^ DO
  229.           BEGIN
  230.           callbackrequest := unifyToFunctor;
  231.           callbackData[1] := termNumber;
  232.           callbackData[3] := 2;
  233.           s := '.';
  234.           callback(entrypoint);
  235.           returnList := callbackData[3] = messageOK;
  236.           END;
  237.       END;
  238.  
  239.     FUNCTION returnStructure(termNumber: termIndex; st: str255; arity: integer;
  240.                              plist: prlxPtr): boolean;
  241.  
  242.       BEGIN
  243.         WITH plist^ DO
  244.           BEGIN
  245.           callbackrequest := unifyToFunctor;
  246.           callbackData[1] := termNumber;
  247.           callbackData[3] := arity;
  248.           s := st;
  249.           callback(entrypoint);
  250.           returnStructure := callbackData[3] = messageOK;
  251.           END;
  252.       END;
  253.  
  254.     FUNCTION returnAtom(termNumber: termIndex; st: str255;
  255.                         plist: prlxPtr): boolean;
  256.  
  257.       BEGIN
  258.         returnAtom := returnStructure(termNumber, st, 0, plist);
  259.       END;
  260.  
  261.     FUNCTION subterm(subtermordinate: integer; termNumber: termIndex;
  262.                      plist: prlxPtr): termIndex;
  263.  
  264.       BEGIN
  265.         WITH plist^ DO
  266.           BEGIN
  267.           callbackrequest := getsubterm;
  268.           callbackData[1] := termNumber;
  269.           callbackData[2] := subtermordinate;
  270.           callback(entrypoint);
  271.           subterm := callbackData[3];
  272.           END;
  273.       END;
  274.  
  275.     FUNCTION newFreeTerm(plist: prlxPtr): termIndex;
  276.  
  277.       BEGIN
  278.         WITH plist^ DO
  279.           BEGIN
  280.           callbackrequest := getFreeTerm;
  281.           callback(entrypoint);
  282.           newFreeTerm := callbackData[1];
  283.           END;
  284.       END;
  285.  
  286.     FUNCTION number(termNumber: termIndex; plist: prlxPtr): boolean;
  287.  
  288.       BEGIN
  289.         WITH plist^ DO
  290.           BEGIN
  291.           callbackrequest := getterminfo;
  292.           callbackData[1] := termNumber;
  293.           callback(entrypoint);
  294.           number := (callbackData[1] = integertag);
  295.           END;
  296.       END;
  297.  
  298.     FUNCTION atom(termNumber: termIndex; plist: prlxPtr): boolean;
  299.  
  300.       BEGIN
  301.         WITH plist^ DO
  302.           BEGIN
  303.           callbackrequest := getterminfo;
  304.           callbackData[1] := termNumber;
  305.           callback(entrypoint);
  306.           atom := (callbackData[1] = atomtag);
  307.           END;
  308.       END;
  309.  
  310.     FUNCTION structure(termNumber: termIndex; plist: prlxPtr): boolean;
  311.  
  312.       BEGIN
  313.         WITH plist^ DO
  314.           BEGIN
  315.           callbackrequest := getterminfo;
  316.           callbackData[1] := termNumber;
  317.           callback(entrypoint);
  318.           structure := (callbackData[1] = structuretag);
  319.           END;
  320.       END;
  321.  
  322.     FUNCTION list(termNumber: termIndex; plist: prlxPtr): boolean;
  323.  
  324.       BEGIN
  325.         WITH plist^ DO
  326.           BEGIN
  327.           callbackrequest := getterminfo;
  328.           callbackData[1] := termNumber;
  329.           callback(entrypoint);
  330.           list := ((callbackData[1] = structuretag) AND (s = '.') AND
  331.                   (callbackData[2] = 2)) OR ((callbackData[1] = atomtag) AND
  332.                   (s = '[]'));
  333.           END;
  334.       END;
  335.  
  336.     FUNCTION variable(termNumber: termIndex; plist: prlxPtr): boolean;
  337.  
  338.       BEGIN
  339.         WITH plist^ DO
  340.           BEGIN
  341.           callbackrequest := getterminfo;
  342.           callbackData[1] := termNumber;
  343.           callback(entrypoint);
  344.           variable := (callbackData[1] = variabletag);
  345.           END;
  346.       END;
  347.  
  348.     FUNCTION value(termNumber: termIndex; plist: prlxPtr): longint;
  349.  
  350.       BEGIN
  351.         WITH plist^ DO
  352.           BEGIN
  353.           callbackrequest := getterminfo;
  354.           callbackData[1] := termNumber;
  355.           callback(entrypoint);
  356.           IF callbackData[1] = integertag
  357.             THEN value := callbackData[2]
  358.             ELSE errorstr('attempt to get value of a non-integer', plist);
  359.           END;
  360.       END;
  361.  
  362.     FUNCTION arity(termNumber: termIndex; plist: prlxPtr): integer;
  363.  
  364.       BEGIN
  365.         WITH plist^ DO
  366.           BEGIN
  367.           callbackrequest := getterminfo;
  368.           callbackData[1] := termNumber;
  369.           callback(entrypoint);
  370.           CASE callbackData[1] OF
  371.             atomtag, integertag, variabletag: arity := 0;
  372.             structuretag: arity := callbackData[2];
  373.             OTHERWISE errorstr('Funny data from getTermInfo in arity', plist);
  374.           END;
  375.           END;
  376.       END;
  377.  
  378.     FUNCTION text(termNumber: termIndex; plist: prlxPtr): str255;
  379.  
  380.       VAR
  381.         st: str255;
  382.         i: integer;
  383.  
  384.       BEGIN
  385.         WITH plist^ DO
  386.           BEGIN
  387.           callbackrequest := getterminfo;
  388.           callbackData[1] := termNumber;
  389.           callback(entrypoint);
  390.           CASE callbackData[1] OF
  391.             atomtag, structuretag: text := s;
  392.             integertag:
  393.               BEGIN
  394.               numtostring(callbackData[2], st);
  395.               text := st;
  396.               END;
  397.             variabletag:
  398.               BEGIN
  399.               numtostring(callbackData[2], st);
  400.               FOR i := 255 DOWNTO 2 DO st[i] := st[i - 1];
  401.               st[1] := '_';
  402.               text := st;
  403.               END;
  404.             OTHERWISE errorstr('Funny data from getTermInfo in text', plist);
  405.           END;
  406.           END;
  407.       END;
  408.  
  409.     FUNCTION drawAlert(ALRTid: integer; st: str255; plist: prlxPtr): longint;
  410.  
  411.       BEGIN
  412.         WITH plist^ DO
  413.           BEGIN
  414.           callbackrequest := drawALRT;
  415.           callbackData[1] := ALRTid;
  416.           s := st;
  417.           callback(entrypoint);
  418.           drawAlert := callbackData[2];
  419.           END;
  420.       END;
  421.  
  422.     FUNCTION centreDialog(DLOGid: integer; plist: prlxPtr): longint;
  423.  
  424.       VAR
  425.         item: integer;
  426.         myDialog: dialogPtr;
  427.  
  428.       BEGIN
  429.         WITH plist^ DO
  430.           BEGIN
  431.   (* ###hack        callbackrequest := drawDLOG;
  432.           callbackData[1] := DLOGid;
  433.            callback(entrypoint);
  434.           centreDialog := callbackData[2]; *)
  435.  
  436.           myDialog := getNewDialog(DLOGid, NIL, windowPtr(1));
  437.           showWindow(myDialog);
  438.           modalDialog(NIL, item);
  439.           disposDialog(myDialog);
  440.           centreDialog := item;
  441.           END;
  442.       END;
  443.  
  444.     PROCEDURE centreSfGetTEXTFile(vertical: integer; str: str255;
  445.                                   VAR reply: sfReply);
  446.  
  447.       VAR
  448.         myPoint: point;
  449.         dialogHandle: dialogTHndl;
  450.         myPort: grafPtr;
  451.         screenWidth, dialogWidth: integer;
  452.         myTypeList: sfTypeList;
  453.  
  454.       BEGIN
  455.         myTypeList[0] := 'TEXT';
  456.         getPort(myPort);
  457.         WITH myPort^.portBits.bounds DO screenWidth := right - left;
  458.         dialogHandle := dialogTHndl(getResource('DLOG', getDlgId));
  459.         WITH dialogHandle^^.boundsRect DO
  460.           BEGIN
  461.           dialogWidth := right - left;
  462.           myPoint.h := (screenWidth - dialogWidth) DIV 2;
  463.           myPoint.v := vertical;
  464.           END;
  465.         sfGetFile(myPoint, str, NIL, 1, myTypeList, NIL, reply);
  466.       END;
  467.  
  468.     PROCEDURE centreSfPutFile(vertical: integer; str: str255; origName: str255;
  469.                               dlgHook: procPtr; VAR reply: sfReply);
  470.  
  471.       VAR
  472.         myPoint: point;
  473.         dialogHandle: dialogTHndl;
  474.         myPort: grafPtr;
  475.         screenWidth, dialogWidth: integer;
  476.  
  477.       BEGIN
  478.         getPort(myPort);
  479.         WITH myPort^.portBits.bounds DO screenWidth := right - left;
  480.         dialogHandle := dialogTHndl(getResource('DLOG', putDlgId));
  481.         WITH dialogHandle^^.boundsRect DO
  482.           BEGIN
  483.           dialogWidth := right - left;
  484.           myPoint.h := (screenWidth - dialogWidth) DIV 2;
  485.           myPoint.v := vertical;
  486.           END;
  487.         sfPutFile(myPoint, str, origName, dlgHook, reply);
  488.       END;
  489.  
  490.     FUNCTION getFileName(VAR FileName: str255;
  491.                          VAR FileVolume: longint): boolean;
  492.  
  493.       VAR
  494.         reply: sfReply;
  495.  
  496.       BEGIN
  497.         centreSfGetTEXTFile(75, '', reply);
  498.         FileName := reply.fName;
  499.         FileVolume := reply.vRefNum;
  500.         getFileName := reply.good;
  501.       END;
  502.  
  503. END.
  504.